Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE02/TPACK/TPACK.ZIP/DEBUG.PAS

Pascal/Delphi Source File | 1995-06-01 | 10.3 KB | 344 lines

{------------------------------------------------------------------------------}
{UNREGISTERED VERSION (6/1/95) PLEASE REDISTRIBUTE IN tPACK.ZIP!
 This revision does not contain everything, nor are the exciting
 DataSetReporter and ExtendedMenu[Item] components included.
 Use SWREG#5906 to receive these, icons and a help file for $130.
 You must register when using this code in a business application!
 You'll receive a license to use this code in up to 50 copies of
 any app you write. In turn you will get responsive e-mail
 tech support and enhancements till I run out of registrations
 or suggestions. Meanwhile.. enjoy the code. Bye! I'll make more.
 {(C)'1995 Michael/Ax-Systems, 71560,[e-mail]}
{------------------------------------------------------------------------------}

unit Debug;

{the Debug component has been activate in the demo so you'd find
your way here. this component still contains some earlier code to
route the log to an ini file and or the printer. you should find
these useful where appropriate.
the control flags are set using AdjustDebugFlags.
route text to the trace window using DebugLog}

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, Toolbar, MiscComp, ExtCtrls;

type
  TDebugDlg = class(TDemoForm)
    Toolbar1: TToolbar;
    ToolButton1: TToolButton;
    Toolbar2: TToolbar;
    Memo1: TMemo;
    procedure ToolButton1Click(Sender: TObject);
  private
    { Private declarations }
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  public
    { Public declarations }
  end;


  TDebugExtendedComponentOptions = (decEnabled, decDesign
                                  , decCreate, decDestroy, decLoaded, decUpdate
                                  , decInsert, decRemove
                                  , decPrint, decFile, decNotePad );

  TDebugExtendedComponentStates =  (decActive,decFormError,decDestroying
                                   ,decPrintSet,decPrinting,decPrintError
                                   ,decFiling,decFileError );

  TDebugExtendedComponentFlags = set of TDebugExtendedComponentOptions;
  TDebugExtendedComponentState = set of TDebugExtendedComponentStates;


{using the flags and log procedure other parts of the app can use debugging services.}

procedure DebugLog(Owner:TComponent;const Text:String); export;

procedure AdjustDebugFlags(Value:TDebugExtendedComponentFlags); export;

{procedure StartNotePad;}

const
  DebugFlags:TDebugExtendedComponentFlags = [];
  DebugState:TDebugExtendedComponentState = [];

implementation

uses
  IniFiles, PasUtils;

const
  DebugLogName= '\debuglog.ini';

var
  DebugFile: TIniFile;
  DebugPrinter: TextFile;

var
  DebugDlg: TDebugDlg;

{$R *.DFM}

procedure DebugLog(Owner:TComponent;const Text:String);
const
  BufSize=144;
  Count:Longint=0;
  indent:Byte=0;
var
  Buffer:PChar;
  offset:byte;
  txt:string;

  procedure tOut(const Text:String);
  begin
    try
      DebugDlg.Memo1.Lines.add(Text);
    except {ignore?}
      end;
  end;

begin

  if not (decEnabled in DebugFlags) or (decDestroying in DebugState) then
    exit;

  if not ((decFormError in DebugState) or (decActive in DebugState)) then
    if not (decFormError in DebugState) then begin
      if DebugDlg=nil then
        DebugDlg:= TDebugDlg.Create(nil)
      else {take our chances on the form really really being there already!}
        ;
      try
        with DebugDlg do begin
          with Memo1.Lines do begin
            Clear;
            Add('Opened '+datetimetostr(now));
            end;
          OnClose:=FormClose;
          Show;
          Update;
          end;
      except
        DebugState:=DebugState+[decFormError];
        raise;
        end;
      DebugState:=DebugState+[decActive]
      end;

  if Owner<>nil then
    if csDesigning in Owner.ComponentState then
      if not (decDesign in DebugFlags) then
        exit;

{  if (pos('.DCL',paramstr(0))>0) then {do nothing inside library!}
{    if (pos('Create',Text)>0) then
    exit;}

  case Text[1] of
  '+',
  '-': offset:=2;
  else
    offset:=1;
  end;
  Count:=Count+1;
  if Text[1] = '-' then
    indent:=indent-2;

  txt:=copy(text,offset,255);
  if owner<>nil then
    Txt:=owner.classname+': '+txt;
  tOut(inttostr(Count)+'. '+Spaces(Indent)+txt);
  {}
  if not (decPrintError in DebugState) and (decPrint in DebugFlags) then begin
    if not (decPrinting in DebugState) then

      raise
        exception.create('WINPRN must be linked to debug.pas for printing');

      {e.g. add 'WINPRN' to the uses clause at the top of the file
       remove/comment out the exception above
       and uncomment the block below.
       WinPrn is originally stored as in \DELPHI\SOURCE\RTL\WIN\WINPRN}

{
      try
        AssignDefPrn(DebugPrinter);
        GetMem(Buffer,BufSize);
        TitlePrn(DebugPrinter,StrPCopy(Buffer,'Debugging '+paramstr(0)));
        FreeMem(Buffer,BufSize);
        Rewrite(DebugPrinter);
        DebugState:=DebugState+[decPrinting];
      except on E: Exception do begin
        DebugState:=DebugState+[decPrintError];
        tOut('ERROR printing! '+E.Message);
        end;
        end;
}
    if not (decPrintError in DebugState) then
      writeln(DebugPrinter
       ,inttostr(Count)+'. '+Spaces(Indent)+txt);
    end;

  if not (decFileError in DebugState) and (decFile in DebugFlags) then begin
    if not (decFiling in DebugState) then
      try
        DebugFile:=TIniFile.Create(DebugLogName);
        DebugFile.EraseSection(paramstr(0));
        DebugFile.Free;
        DebugState:=DebugState+[decFiling];
      except on E: Exception do begin
        tOut('ERROR erasing section! '+E.Message);
        DebugState:=DebugState+[decFileError];
        end;
        end;
    if (decFiling in DebugState) then
      try
        DebugFile:=TIniFile.Create(DebugLogName);
        DebugFile.WriteString(paramstr(0),IntToStr(Count),'.'+Spaces(Indent)+txt);
        DebugFile.Free;
      except on E: Exception do begin
        tOut('ERROR writing string! '+E.Message);
        DebugState:=DebugState+[decFileError];
        end;
        end;
    end;
  {}
  if Text[1] = '+' then
    indent:=indent+2;

end;

{}

procedure StartNotePad; {could instantiate a shell, but let be simple here.}
const
  BufSize=144;
var
  Buffer:PChar;
begin
  GetMem(Buffer,BufSize);
  WinExec(StrPCopy(Buffer,'Notepad '+DebugLogName),sw_ShowNormal);
  FreeMem(Buffer,BufSize);
end;

{}

procedure AdjustDebugFlags(Value:TDebugExtendedComponentFlags);
begin
  if not (decPrint in Value) and (decPrint in DebugFlags) then  {print off}
    if (decPrinting in DebugState) then begin
      CloseFile(DebugPrinter);
      DebugState:=DebugState-[decPrinting];
      end;

  if not (decFile in Value) and (decFile in DebugFlags) then  {file off}
    if (decFiling in DebugState) then begin
      DebugState:=DebugState-[decFiling];
      if (decNotePad in DebugFlags) then
        StartNotePad;
      end;

  if not (decEnabled in Value) and (decEnabled in DebugFlags) then begin{turn all off}
    Value:=Value-[decCreate,decDesign,decDestroy,decLoaded,decUpdate,decInsert,decRemove];
    end;
  if (decEnabled in Value) and not (decEnabled in DebugFlags) then begin{turn all on}
    Value:=Value+[decCreate,decDesign,decDestroy,decLoaded,decUpdate,decInsert,decRemove];
    end;

  DebugFlags:=Value;
end;


{-----------------------------------------------------------------------------------------}
{                                                                                         }
{-----------------------------------------------------------------------------------------}

procedure TDebugDlg.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action:=caFree;
  DebugDlg:=nil;
  {DebugState:=DebugState-[decActive];}
  DebugState:= [];
end;

procedure TDebugDlg.ToolButton1Click(Sender: TObject);
begin
  Close;
end;


{-----------------------------------------------------------------------------------------}
{ INITIALIZATION AND EXIT PROCEDURES                                                      }
{-----------------------------------------------------------------------------------------}

procedure InitializeUnit;
var
  i:integer;
  a:string;
begin
  DebugFlags:= [];
  DebugState:= [];
 { if csDesigning in ComponentState then exit;}
  {process the commandline to set the unit's globals to the desired DEBUG state.}
  for i:=1 to ParamCount do begin
    a:=uppercase(ParamStr(i));
    if copy(a,1,2)='/D' then begin
      DebugFlags:=DebugFlags+[decEnabled];
      if Length(a)=2 then
        DebugFlags:=DebugFlags+[decCreate,decDesign,decDestroy,decLoaded,decUpdate,decInsert,decRemove]
      else begin
        if pos('C',a)>0 then DebugFlags:=DebugFlags+[decCreate];
        if pos('D',a)>0 then DebugFlags:=DebugFlags+[decDesign];
        if pos('L',a)>0 then DebugFlags:=DebugFlags+[decLoaded];
        if pos('U',a)>0 then DebugFlags:=DebugFlags+[decUpdate];
        if pos('I',a)>0 then DebugFlags:=DebugFlags+[decInsert];
        if pos('R',a)>0 then DebugFlags:=DebugFlags+[decRemove];
        if pos('P',a)>0 then DebugFlags:=DebugFlags+[decPrint];
        if pos('F',a)>0 then DebugFlags:=DebugFlags+[decFile];
        if pos('N',a)>0 then DebugFlags:=DebugFlags+[decNotepad];
        end;
      end;
    end;
end;

{-----------------------------------------------------------------------------------------}

procedure FinalizeUnit;
begin
  if (decPrint in DebugFlags) or (decFile in DebugFlags) then {turn off}
    AdjustDebugFlags([]); {stores back into global}
end;

{-----------------------------------------------------------------------------------------}
{-----------------------------------------------------------------------------------------}

Const
  Initialized: boolean = False;
  SaveExit: Pointer =nil;                    { Saves the old ExitProc }

procedure Finalize; far;
begin
  ExitProc := SaveExit;
  FinalizeUnit;
end;

procedure Initialize;
begin
  if not Initialized then begin
    Initialized:=True;
    SaveExit := ExitProc;
    ExitProc := @Finalize;
    InitializeUnit;
    end;
end;

initialization
  Initialize;
end.